home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Thomas / run-collections-list.scm < prev    next >
Encoding:
Text File  |  1992-11-25  |  14.9 KB  |  274 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-collections-list.scm,v 1.17 1992/08/31 05:00:58 birkholz Exp $
  39.  
  40. ;;;; This file contains all the specializations for list, pair, and
  41. ;;;; empty-list type.
  42.  
  43.  
  44. (add-method dylan:binary=
  45.   (dylan::function->method
  46.    two-lists
  47.    (lambda (list-1 list-2)
  48.      (let ((size-1 (dylan-call dylan:size list-1))
  49.        (size-2 (dylan-call dylan:size list-2)))
  50.        (if (not (= size-1 size-2))
  51.        #F
  52.        (do ((state-1 (dylan-call dylan:initial-state list-1)
  53.              (dylan-call dylan:next-state list-1 state-1))
  54.         (state-2 (dylan-call dylan:initial-state list-2)
  55.              (dylan-call dylan:next-state list-2 state-2)))
  56.            ((or (or (not state-1) (not state-2))
  57.             (not (dylan-call dylan:id?
  58.                      (dylan-call dylan:current-element
  59.                          list-1 state-1)
  60.                      (dylan-call dylan:current-element
  61.                          list-2 state-2))))
  62.         (if (or state-1 state-2) #F #T))))))))
  63.  
  64. (add-method dylan:as
  65.   (dylan::function->method
  66.    (make-param-list `((CLASS ,(dylan::make-singleton <list>))
  67.               (COLLECTION ,<collection>)) #F #F #F)
  68.    (lambda (class collection)
  69.      class
  70.      (if (dylan-call dylan:instance? collection <list>)
  71.      collection
  72.      (let loop ((state (dylan-call dylan:initial-state collection))
  73.             (result '()))
  74.        (if state
  75.            (loop (dylan-call dylan:next-state collection state)
  76.              (cons (dylan-call dylan:current-element collection state)
  77.                result))
  78.            (reverse result)))))))
  79.  
  80.  
  81. (add-method dylan:as
  82.   (dylan::function->method
  83.    (make-param-list `((CLASS ,(dylan::make-singleton <pair>))
  84.               (COLLECTION ,<collection>)) #F #F #F)
  85.    (lambda (class collection)
  86.      class
  87.      (if (dylan-call dylan:instance? collection <pair>)
  88.      collection
  89.      (let loop ((state (dylan-call dylan:initial-state collection))
  90.             (result '()))
  91.        (if state
  92.            (loop (dylan-call dylan:next-state collection state)
  93.              (cons (dylan-call dylan:current-element collection state)
  94.                result))
  95.            (reverse result)))))))
  96.  
  97.  
  98. ;;;
  99. ;;; LIST SPECIALIZED MAKE
  100. ;;; supports size: and fill:
  101. ;;;
  102. (add-method
  103.  dylan:make
  104.  (dylan::dylan-callable->method
  105.   (make-param-list `((LIST ,(dylan::make-singleton <list>)))
  106.            #F #F '(size: fill:))
  107.   (lambda (multiple-values next-method class . rest)
  108.     multiple-values class                ; Not used
  109.     (dylan::keyword-validate next-method rest '(size: fill:))
  110.     (let* ((size (dylan::find-keyword rest 'size: (lambda () 0)))
  111.        (have-fill? #T)
  112.        (fill (dylan::find-keyword rest 'fill:
  113.                       (lambda () (set! have-fill? #F) #F))))
  114.       (if (or (not (integer? size)) (negative? size))
  115.     ll dylan:cdr list)))))
  116.  
  117. (define dylan:cdar
  118.   (dylan::function->method
  119.    one-list
  120.    (lambda (list) (dylan-call dylan:cdr (dylan-call dylan:car list)))))
  121.  
  122. (define dylan:cddr
  123.   (dylan::function->method
  124.    one-list
  125.    (lambda (list) (dylan-call dylan:cdr (dylan-call dylan:cdr list)))))
  126.  
  127. (define dylan:caaar
  128.   (dylan::function->method
  129.    one-list
  130.    (lambda (list)
  131.      (dylan-call dylan:car
  132.          (dylan-call dylan:car (dylan-call dylan:car list))))))
  133.  
  134. (define dylan:caadr
  135.   (dylan::function->method
  136.    one-list
  137.    (lambda (list)
  138.      (dylan-call dylan:car
  139.          (dylan-call dylan:car (dylan-call dylan:cdr list))))))
  140.  
  141. (define dylan:cadar
  142.   (dylan::function->method
  143.    one-list
  144.    (lambda (list)
  145.      (dylan-call dylan:car
  146.          (dylan-call dylan:cdr (dylan-call dylan:car list))))))
  147.  
  148. (define dylan:caddr
  149.   (dylan::function->method
  150.    one-list
  151.    (lambda (list)
  152.      (dylan-call dylan:car
  153.          (dylan-call dylan:cdr (dylan-call dylan:cdr list))))))
  154.  
  155. (define dylan:cdaar
  156.   (dylan::function->method
  157.    one-list
  158.    (lambda (list)
  159.      (dylan-call dylan:cdr
  160.          (dylan-call dylan:car (dylan-call dylan:car list))))))
  161.  
  162. (define dylan:cdadr
  163.   (dylan::function->method
  164.    one-list
  165.    (lambda (list)
  166.      (dylan-call dylan:cdr
  167.          (dylan-call dylan:car (dylan-call dylan:cdr list))))))
  168.  
  169. (define dylan:cddar
  170.   (dylan::function->method
  171.    one-list
  172.    (lambda (list)
  173.      (dylan-call dylan:cdr
  174.          (dylan-call dylan:cdr (dylan-call dylan:car list))))))
  175.  
  176. (define dylan:cdddr
  177.   (dylan::function->method
  178.    one-list
  179.    (lambda (list)
  180.      (dylan-call dylan:cdr
  181.          (dylan-call dylan:cdr (dylan-call dylan:cdr list))))))
  182.  
  183. (define dylan:setter/car/
  184.   (dylan::function->method
  185.    one-list-and-an-object
  186.    (lambda (list object) (set-car! list object) object)))
  187.  
  188. (define dylan:setter/cdr/
  189.   (dylan::function->method
  190.    one-list-and-an-object
  191.    (lambda (list object) (set-cdr! list object) object)))
  192.  
  193. (define dylan:setter/caar/
  194.   (dylan::function->method
  195.    one-list-and-an-object
  196.    (lambda (list object)
  197.      (set-car! (dylan-call dylan:car list) object)
  198.      object)))
  199.  
  200. (define dylan:setter/cadr/
  201.   (dylan::function->method
  202.    one-list-and-an-object
  203.    (lambda (list object)
  204.      (set-car! (dylan-call dylan:cdr list) object)
  205.      object)))
  206.  
  207. (define dylan:setter/cdar/
  208.   (dylan::function->method
  209.    one-list-and-an-object
  210.    (lambda (list object)
  211.      (set-cdr! (dylan-call dylan:car list) object)
  212.      object)))
  213.  
  214. (define dylan:setter/cddr/
  215.   (dylan::function->method
  216.    one-list-and-an-object
  217.    (lambda (list object)
  218.      (set-cdr! (dylan-call dylan:cdr list) object)
  219.      object)))
  220.  
  221. (define dylan:setter/caaar/
  222.   (dylan::function->method
  223.    one-list-and-an-object
  224.    (lambda (list object)
  225.      (set-car! (dylan-call dylan:car (dylan-call dylan:car list)) object)
  226.      object)))
  227.  
  228. (define dylan:setter/caadr/
  229.   (dylan::function->method
  230.    one-list-and-an-object
  231.    (lambda (list object)
  232.      (set-car! (dylan-call dylan:car (dylan-call dylan:cdr list)) object)
  233.      object)))
  234.  
  235. (define dylan:setter/cadar/
  236.   (dylan::function->method
  237.    one-list-and-an-object
  238.    (lambda (list object)
  239.      (set-car! (dylan-call dylan:cdr (dylan-call dylan:car list)) object)
  240.      object)))
  241.  
  242. (define dylan:setter/caddr/
  243.   (dylan::function->method
  244.    one-list-and-an-object
  245.    (lambda (list object)
  246.      (set-car! (dylan-call dylan:cdr (dylan-call dylan:cdr list)) object)
  247.      object)))
  248.  
  249. (define dylan:setter/cdaar/
  250.   (dylan::function->method
  251.    one-list-and-an-object
  252.    (lambda (list object)
  253.      (set-cdr! (dylan-call dylan:car (dylan-call dylan:car list)) object)
  254.      object)))
  255.  
  256. (define dylan:setter/cdadr/
  257.   (dylan::function->method
  258.    one-list-and-an-object
  259.    (lambda (list object)
  260.      (set-cdr! (dylan-call dylan:car (dylan-call dylan:cdr list)) object)
  261.      object)))
  262.  
  263. (define dylan:setter/cddar/
  264.   (dylan::function->method
  265.    one-list-and-an-object
  266.    (lambda (list object)
  267.      (set-cdr! (dylan-call dylan:cdr (dylan-call dylan:car list)) object)
  268.      object)))
  269.  
  270. (define dylan:setter/cdddr/
  271.   (dylan::function->method
  272.    one-list-and-an-object
  273.    (lambda (list object)
  274.      (set-cdr! (dylan-call dylan:cdr (dylan-call dylan:cdr list)